#lang racket


(require racket/gui/base
         sgl
         sgl/gl
         sgl/gl-vectors)

(require "../base/main.rkt"
         "../proxies/main.rkt")

(provide load-opengl-methods
         
         ; points
         point
         
         ; solids
         box
         cone
         cone-frustum
         cylinder
         sphere
         
         ; transformations
         intersect
         move
         rotate
         scale
         
         (rename-out (clear! delete-shapes))
         enable-redraw)


(define-syntax with-gl-shape
  (syntax-rules ()
    ((_ name body ...)
     (begin
       (gl-begin name)
       body ...
       (gl-end)))))

(define-syntax with-gl-attrib
  (syntax-rules ()
    ((_ body ...)
     (begin
       (gl-push-attrib 'all-attrib-bits)
       body ...
       (gl-pop-attrib)))))

(define-syntax with-gl-matrix
  (syntax-rules ()
    ((_ body ...)
     (begin
       (gl-push-matrix)
       body ...
       (gl-pop-matrix)))))

(define-syntax with-gl-projection-matrix
  (syntax-rules ()
    ((_ body ...)
     (begin
       (gl-matrix-mode 'projection)
       (with-gl-matrix
        body ...
        (gl-matrix-mode 'projection))))))

(define-syntax with-gl-modelview-matrix
  (syntax-rules ()
    ((_ body ...)
     (begin
       (gl-matrix-mode 'modelview)
       (with-gl-matrix
        body ...
        (gl-matrix-mode 'modelview))))))

(define quadric 
  (let ((quadric #f))
    (lambda ()
      (or quadric
          (begin
            (set! quadric (gluNewQuadric))
            quadric)))))

(define lighting? #t)
(define time? #f)

(define perspective-angle 45.0)
(define perspective-near-plane 1.0)
(define perspective-far-plane 2000.0)


(define (matrix<-gl-vector v)
  (m-cols (gl-vector->vector v)))

(define (gl-vector<-matrix m)
  (vector->gl-double-vector (vector-cols<-matrix m)))


(define idcounter 0)

(define (genid)
  (let ((id idcounter))
    (set! idcounter (+ idcounter 1))
    id))


(define gl-identity (gl-vector<-matrix m-identity))


(struct opengl-id id (n (m #:mutable)))
(struct dl-id opengl-id (dl))


(define opengl-ids (make-hasheqv))

(define (add! object)
  (hash-set! opengl-ids (opengl-id-n object) object)
  object)

(define (remove! object)
  (hash-remove! opengl-ids (opengl-id-n object)))

(define (clear!)
  (set! opengl-ids (make-hasheqv)))

; point

(struct point-id opengl-id ())

(define (point c)
  (add! (point-id (genid) (gl-vector<-matrix (m-translation c)))))

(define (draw-point)
  (with-gl-shape
   'points
    (gl-vertex 0 0 0)))

; /point



; box

(define (draw-box)
  (with-gl-matrix
   (gl-normal 0.0 0.0 1.0)
   (with-gl-shape
    'quads
    (gl-vertex 1 1 -1) ; Top Right Of The Quad (Top)
    (gl-vertex -1 1 -1) ; Top Left Of The Quad (Top)
    (gl-vertex -1 1 1) ; Bottom Left Of The Quad (Top)
    (gl-vertex 1 1 1) ; Bottom Right Of The Quad (Top)
    )
   
   (gl-normal 0.0 0.0 -1.0)
   (with-gl-shape
    'quads
    (gl-vertex 1 -1 1) ; Top Right Of The Quad (Bottom)
    (gl-vertex -1 -1 1) ; Top Left Of The Quad (Bottom)
    (gl-vertex -1 -1 -1) ; Bottom Left Of The Quad (Bottom)
    (gl-vertex 1 -1 -1) ; Bottom Right Of The Quad (Bottom)
    )
   
   (gl-normal 0.0 1.0 0.0)
   (with-gl-shape
    'quads
    (gl-vertex 1 1 1) ; Top Right Of The Quad (Front)
    (gl-vertex -1 1 1) ; Top Left Of The Quad (Front)
    (gl-vertex -1 -1 1) ; Bottom Left Of The Quad (Front)
    (gl-vertex 1 -1 1) ; Bottom Right Of The Quad (Front)
    )
   
   (gl-normal 0.0 -1.0 0.0)
   (with-gl-shape
    'quads
    (gl-vertex 1 -1 -1) ; Top Right Of The Quad (Back)
    (gl-vertex -1 -1 -1) ; Top Left Of The Quad (Back)
    (gl-vertex -1 1 -1) ; Bottom Left Of The Quad (Back)
    (gl-vertex 1 1 -1) ; Bottom Right Of The Quad (Back)
    )
   
   (gl-normal 1.0 0.0 0.0)
   (with-gl-shape
    'quads
    (gl-vertex -1 1 1) ; Top Right Of The Quad (Left)
    (gl-vertex -1 1 -1) ; Top Left Of The Quad (Left)
    (gl-vertex -1 -1 -1) ; Bottom Left Of The Quad (Left)
    (gl-vertex -1 -1 1) ; Bottom Right Of The Quad (Left)
    )
   
   (gl-normal -1.0 0.0 0.0)
   (with-gl-shape
    'quads
    (gl-vertex 1 1 -1) ; Top Right Of The Quad (Right)
    (gl-vertex 1 1 1) ; Top Left Of The Quad (Right)
    (gl-vertex 1 -1 1) ; Bottom Left Of The Quad (Right)
    (gl-vertex 1 -1 -1))))


(define-syntax (define-display-list stx)
  (syntax-case stx ()
    ((_ name expr)
     #'(define name 
         (let ((dl #f))
           (lambda ()
             (or dl
                 (begin
                   (set! dl (gl-gen-lists 1))
                   (gl-new-list dl 'compile)
                   expr
                   (gl-end-list)
                   dl))))))))

(define-display-list box-dl (draw-box))

(struct box-id opengl-id (w l h))

(define (box w l h)
  (add! (box-id (genid) gl-identity w l h)))

(define (draw-box-id w l h)
  (with-gl-matrix
   (gl-scale w l h)
   (gl-call-list (box-dl))))

; /box


; camera

(define camera-pos (xyz 10.0 10.0 10.0))
(define camera-target u0)

(define (camera-dir) (sub-c camera-target camera-pos))

(define (draw-camera)
  (gluLookAt
   (xyz-x camera-pos) (xyz-y camera-pos) (xyz-z camera-pos)
   (xyz-x camera-target) (xyz-y camera-target) (xyz-z camera-target)
   0.0 0.0 1.0))

; /camera

; cone-frustum

(define cone-frustum-slices 50)
(define cone-frustum-stacks 50)

(define (draw-cone-frustum br tr h)

  (define (draw-base r)
    (gluQuadricOrientation (quadric) GLU_INSIDE)
    (gluDisk (quadric) 0.0 r cone-frustum-slices cone-frustum-stacks))
  
  (define (draw-top-base r)
    (with-gl-matrix
     (gl-translate 0.0 0.0 h)
     (gluQuadricOrientation (quadric) GLU_OUTSIDE)
     (gluDisk (quadric) 0.0 r cone-frustum-slices cone-frustum-stacks)))
  
  (define (draw-side)
    (gl-disable 'cull-face)
    (gluCylinder
     (quadric)
     br tr h
     cone-frustum-slices cone-frustum-stacks)
    (gl-enable 'cull-face))
  
  (draw-base br)
  (draw-top-base tr)
  (draw-side))

(struct cone-frustum-id opengl-id (br tr h))

(define (cone-frustum br tr h)
  (add! (cone-frustum-id (genid) gl-identity br tr h)))

(define (draw-cone-frustum-id br tr h)
  (draw-cone-frustum br tr h))

; /cone-frustum

; cylinder

(define-display-list cylinder-dl (draw-cone-frustum 1 1 1))

(struct cylinder-id opengl-id (r h))

(define (cylinder r h)
  (add! (cylinder-id (genid) gl-identity r h)))

(define (draw-cylinder-id r h)
  (with-gl-matrix
   (gl-scale r r h)
   (gl-call-list (cylinder-dl))))

; /cylinder

; cone

(define-display-list cone-dl (draw-cone-frustum 1 0 1))

(struct cone-id opengl-id (r h))

(define (cone r h)
  (add! (cone-id (genid) gl-identity r h)))

(define (draw-cone-id r h)
  (with-gl-matrix
   (gl-scale r r h)
   (gl-call-list (cone-dl))))

; /cone

; sphere

(define sphere-slices 50)
(define sphere-stacks 50)

(define (draw-sphere r)
  (gluSphere (quadric) r sphere-slices sphere-stacks))

(define-display-list sphere-dl (draw-sphere 1))

(struct sphere-id opengl-id (r))

(define (sphere r)
  (add! (sphere-id (genid) gl-identity r)))

(define (draw-sphere-id r)
  (with-gl-matrix
   (gl-scale r r r)
   (gl-call-list (sphere-dl))))

; /sphere


; transformations

; intersect

(struct intersect-id opengl-id (ids))

(define (intersect ids)
  (for-each remove! ids)
  (add! (intersect-id (genid) gl-identity ids)))

(define biguint (string->number (make-string 31 #\1) 2))

(define (draw-opengl-id-stencil-mask id)
  (gl-clear 'stencil-buffer-bit)
  (gl-color-mask #f #f #f #f)
  (gl-depth-mask #f)
  
  (with-gl-attrib
   (gl-enable 'stencil-test)
   (gl-stencil-func 'always 1 biguint)
   (gl-stencil-op 'replace 'replace 'replace)
   
   (gl-disable 'depth-test)
   
   (draw-opengl-id id #:lighting? #f))
  
  (gl-color-mask #t #t #t #t)
  (gl-depth-mask #t))

(define (draw-opengl-id-stencil-match id i)
  (displayln i)
  (gl-color-mask #f #f #f #f)
  (gl-depth-mask #f)
  
  (with-gl-attrib
   (gl-enable 'stencil-test)
   (gl-stencil-func 'equal (- i 1) biguint)
   (gl-stencil-op 'zero 'zero 'incr)
   
   (gl-disable 'depth-test)
   
   (draw-opengl-id id #:lighting? #f))
  
  (gl-color-mask #t #t #t #t)
  (gl-depth-mask #t))

(define (draw-opengl-id-stencil-final id i)
  (displayln i)
  (with-gl-attrib
   (gl-enable 'stencil-test)
   (gl-stencil-func 'never 3 biguint)
   (gl-stencil-op 'keep 'keep 'keep)
   
   (draw-opengl-id id)))

(define (draw-intersect ids)
  (displayln 'intersection)
  (draw-opengl-id-stencil-mask (first ids))
  (for ((id (rest ids))
        (i (in-naturals 2)))
    (draw-opengl-id-stencil-match id i))
  (let ((len (length ids)))
    (for ((id ids))
      (draw-opengl-id-stencil-final id len))))

; /intersect


(define (move c id)
  (begin0
    id
    (let ((m
           (gl-vector<-matrix
            (*m (m-translation c) (matrix<-gl-vector (opengl-id-m id))))))
      (set-opengl-id-m! id m))))

(define (rotate a n id)
  (begin0
    id
    (let ((m
           (gl-vector<-matrix
            (*m (m-rotation a n) (matrix<-gl-vector (opengl-id-m id))))))
      (set-opengl-id-m! id m))))

(define (scale type c id/ids)
  (define (scale-id id)
    (let ((m
           (gl-vector<-matrix
            (*m (m-scaling c) (matrix<-gl-vector (opengl-id-m id))))))
      (set-opengl-id-m! id m)))
  
  (begin0
    id/ids
    (if (list? id/ids)
        (for-each scale-id id/ids)
        (scale-id id/ids))))


(define (draw-opengl-id id #:lighting? (lighting? lighting?))
  (with-gl-attrib
   (when lighting? (gl-enable 'lighting))
   
   (with-gl-matrix
    (gl-mult-matrix (opengl-id-m id))
    (match id
      ((point-id _ _) (draw-point))
      ((box-id _ _ w l h) (draw-box-id w l h))
      ((cone-id _ _ r h) (draw-cone-id r h))
      ((cone-frustum-id _ _ br tr h) (draw-cone-frustum-id br tr h))
      ((cylinder-id _ _ r h) (draw-cylinder-id r h))
      ((sphere-id _ _ r) (draw-sphere-id r))
      
      ; transformations
      ((intersect-id _ _ ids) (draw-intersect ids))))))


(define redraw? #t)

(define (enable-redraw v)
  (set! redraw? v))


(define (draw-axes)
  (with-gl-attrib
   (gl-disable 'depth-test)
   
   (with-gl-projection-matrix
    (gl-load-identity)
    (gl-ortho -1.0 1.0 -1.0 1.0 -1.0 100.0)
    
    (with-gl-modelview-matrix
     (gl-load-identity)
     (gl-translate -0.9 -0.9 0.0)
     (let ((dir (mult-c (camera-dir) -1)))
       (gluLookAt (xyz-x dir) (xyz-y dir) (xyz-z dir)
                  0.0 0.0 0.0
                  0.0 0.0 1.0))
     
     (gl-scale 0.1 0.1 0.1)
     
     (with-gl-shape 
      'lines
      (gl-color 1.0 0.0 0.0)
      (gl-vertex 0 0 0)
      (gl-vertex 1 0 0)
      (gl-color 0.0 1.0 0.0)
      (gl-vertex 0 0 0)
      (gl-vertex 0 1 0)
      (gl-color 0.0 0.0 1.0)
      (gl-vertex 0 0 0)
      (gl-vertex 0 0 1)))))
  (gl-matrix-mode 'modelview))

(define (draw-floor)
  (gl-depth-mask #f)
  
  (with-gl-attrib
   (gl-enable 'blend)
   (gl-blend-func 'src-alpha 'one-minus-src-alpha)
   
   (gl-disable 'cull-face)
   
   (with-gl-matrix
    (gl-scale 100.0 100.0 1.0)
    
    (gl-color 1.0 1.0 1.0 0.15)
    
    (with-gl-shape
     'quads
     (gl-vertex -1.0 -1.0 0.0)
     (gl-vertex 1.0 -1.0 0.0)
     (gl-vertex 1.0 1.0 0.0)
     (gl-vertex -1.0 1.0 0.0))))
  
  (gl-depth-mask #t))

(define (draw-grid)  
  (with-gl-attrib
   (with-gl-matrix
    (gl-scale 100.0 100.0 1.0)
    
    (gl-color 1.0 1.0 1.0)
    
    (for ((i 100))
      (gl-begin 'lines)
      (gl-vertex (+ -1.0 (/ i 50)) -1.0 0.0)
      (gl-vertex (+ -1.0 (/ i 50)) 1.0 0.0)
      (gl-end))
    
    (for ((i 100))
      (gl-begin 'lines)
      (gl-vertex -1.0 (+ -1.0 (/ i 50)) 0.0)
      (gl-vertex 1.0 (+ -1.0 (/ i 50)) 0.0)
      (gl-end)))))


(define opengl-canvas%
  (class* canvas% ()
    
    (inherit get-parent
             get-top-level-window
             refresh
             swap-gl-buffers
             with-gl-context)
    
    (define mouse-x 0)
    (define mouse-y 0)
    (define mouse-pan? #f)
    (define mouse-orbit? #f)
    
    (define rotation 0.0)
    
    (define view-rotx 0.0)
    (define view-roty 0.0)
    (define view-rotz 0.0)
    
    (define grid? #t)
    (define wireframe? #f)
    
    (define step? #f)
    
    (define/public (run)
      (set! step? #t)
      (refresh))
    
    (define/public (stop)
      (set! step? #f)
      (refresh))
    
    (define/private (report-no-gl)
      (message-box "Rosetta"
                   (string-append
                    "There was an error initializing OpenGL. "
                    "Maybe OpenGL is not supported on the current platform.")
                   (get-top-level-window)
                   '(ok stop))
      (exit 1))
    
    (define/override (on-char event)
      (let ((key (send event get-key-code)))
        (cond ((eq? key 'wheel-up)
               (let ((r (if (send event get-shift-down) 10.0 1.0)))
                 (set! camera-pos (add-r-c camera-pos (- r))))
               (refresh))
              ((eq? key 'wheel-down)
               (let ((r (if (send event get-shift-down) 10.0 1.0)))
                 (set! camera-pos (add-r-c camera-pos r)))
               (refresh))
              ((eq? key #\g)
               (set! grid? (not grid?)))
              ((eq? key #\l)
               (set! lighting? (not lighting?)))
              ((eq? key #\t)
               (displayln "TIME")
               (set! time? (not time?)))
              ((eq? key #\w)
               (set! wireframe? (not wireframe?))))))
    
    (define/override (on-event event)
      (when (is-a? event mouse-event%)
        (case (send event get-event-type)
          ('left-down
           (set! mouse-x (send event get-x))
           (set! mouse-y (send event get-y))
           (set! mouse-pan? #t))
          ('left-up
           (set! mouse-pan? #f))
          ('right-down
           (set! mouse-x (send event get-x))
           (set! mouse-y (send event get-y))
           (set! mouse-orbit? #t))
          ('right-up
           (set! mouse-orbit? #f))
          ('motion
           (let ((dx (- mouse-x (send event get-x)))
                 (dy (- mouse-y (send event get-y))))
             (when mouse-pan?
               (set! camera-pos (add-x-c camera-pos (/ (- dx) 100.0)))
               (set! camera-pos (add-z-c camera-pos (/ (- dy) 100.0)))
               (set! camera-target (add-x-c camera-target (/ (- dx) 100.0)))
               (set! camera-target (add-z-c camera-target (/ (- dy) 100.0)))
               (set! mouse-x (send event get-x))
               (set! mouse-y (send event get-y))
               (refresh))
             (when mouse-orbit?
               (set! camera-pos (add-phi-c camera-pos (/ dx 100.0)))
               (set! camera-pos (add-th-c camera-pos (/ dy 100.0)))
               (set! mouse-x (send event get-x))
               (set! mouse-y (send event get-y))
               (refresh)))))))
    
    (define/override (on-size width height)
      (with-gl-context
       #:fail (thunk (report-no-gl))
       (thunk
        ;           (printf "  RENDERER:   ~A\n" (gl-get-string 'renderer))
        ;           (printf "  VERSION:    ~A\n" (gl-get-string 'version))
        ;           (printf "  VENDOR:     ~A\n" (gl-get-string 'vendor))
        ;           (printf "  EXTENSIONS: ~A\n" (gl-get-string 'extensions)))
        
        (gl-viewport 0 0 width height)
        
        (gl-matrix-mode 'projection)
        (gl-load-identity)
        (let ((r (/ width height)))
          (gluPerspective
           perspective-angle
           r
           perspective-near-plane
           perspective-far-plane))
        
        (gl-matrix-mode 'modelview)
        (gl-load-identity)
        
        (gl-enable 'cull-face)
        (gl-enable 'depth-test)
        (gl-enable 'normalize)
        
        (gl-enable 'light0)
        (gl-light-v 'light0 'position (vector->gl-float-vector (vector 5.0 5.0 10.0 0.0)))
        
        (refresh))))
    
    (define sec (current-seconds))
    (define frames 0)
    
    (define (draw-scene)
      (with-gl-context
       #:fail (thunk (report-no-gl))
       (thunk
        (gl-clear-color 0.0 0.0 0.0 0.0)
        (gl-clear 'color-buffer-bit 'depth-buffer-bit 'stencil-buffer-bit)
        
        (if wireframe?
            (gl-polygon-mode 'front-and-back 'line)
            (gl-polygon-mode 'front-and-back 'fill))
        
        (with-gl-matrix
         (draw-camera)
         (for ((id (in-hash-values opengl-ids))) (draw-opengl-id id))
         (when grid?
           (draw-grid)
           (draw-floor))
         (draw-axes))
        
        (gl-flush)
        (swap-gl-buffers))))
    
    (define/override (on-paint)        
      (when step?
        ;; TODO: Don't increment this infinitely.
        (set! rotation (+ 2.0 rotation)))
      
      (cond (time?
             (set! time? #f)
             (time (draw-scene)))
            (else
             (draw-scene)))
      
      (when step?
        (set! step? #f)
        (queue-callback (λ _ (send this run)) #f)))
    
    (super-instantiate () (style '(gl no-autoclear)))))

(define (load-opengl-canvas)
  (let* ((frame (make-object frame% "Rosetta - OpenGL" #f))
         (canvas (instantiate opengl-canvas% (frame) (min-width 600) (min-height 600))))
    ;(send frame create-status-line)
    (send frame show #t)
    (send canvas run)
    canvas))


(define opengl-canvas #f)

(define (load-opengl-methods)
  (unless opengl-canvas
    (set! opengl-canvas (load-opengl-canvas))))